Pensieve Header: Wheeled Semi-Symmetrized calculus in the 2D quotient.

Continues “Semi-Symmetrized 2D Calculus.nb”, “A 2D B-Picture, IV.nb”, uses computations from “BCH in Blobs.nb” and from “111223 Calculator.nb”, “111227 Calculator.nb”, “111228 Calculator.nb”, and “111230 Calculator.nb”. Continued in “2012-01/betaCalculus.nb”.

SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\w-Computations"]

ar[i_,j_] := t[i]h[j]; R[i_, j_] := W[1]+ar[i,j](E^c[i]-1)/c[i];

μCollect[μ_] := Collect[μ, _h, Collect[#, _t, Simplify]&] /. W[ws_] :> W[Simplify[ws]];
SetAttributes[μForm, Listable];
μForm[μ_] := Module[
{tails, heads, mat},
tails = Union[Cases[μ, t[s_] :> s, Infinity]];
heads = Union[Cases[μ, h[s_] :> s, Infinity]];
mat = Outer[FullSimplify[Coefficient[μ, h[#1] t[#2]]]&, heads, tails];
PrependTo[mat, t /@ tails];
mat = Prepend[Transpose[mat],
Prepend[h /@ heads, μ /. (h[_]|t[_]) -> 0]
];
MatrixForm[mat]
]

Tails Works

tm[x_,y_,z_][μ_] := μCollect[μ /. {t[x]|t[y] -> t[z], c[x]|c[y] -> c[z]}];
tΔ[z_, x_, y_][μ_] := μCollect[μ /. {t[z] -> t[x]+t[y], c[z] -> c[x]+c[y]}];
tS[x_][μ_] := μCollect[μ /. {t[x] -> -t[x], c[x] -> -c[x]}];

Heads Works

hm[x_,y_,z_][μ_] := Module[
{ξ, η},
ξ = D[μ, h[x]];
η = D[μ, h[y]];
μCollect[(μ /. h[x|y]->0) + ξ h[z] + (1+ξ /. t[s_]:>c[s])η h[z]]
];
hΔ[z_, x_, y_][μ_] := μCollect[μ /. h[z] -> h[x]+h[y]];
hS[x_][μ_] := Module[{β},
β = 1 + D[μ, h[x]] /. t[s_]:>c[s];
μCollect[μ /. h[x] -> -h[x]/β]
];

hm[3,4,5][ar[1,3]+ar[2,4]]

hm[3,4,5][ar[1,3]+ar[2,4]] // μForm

Associativity of Heads Multiplication

μ1=α1 ar[1,1]+α2 ar[2,2]+α3 ar[3,3]

μ1 // μForm

μ1 // hm[1,2,1] // μForm

(t1=μ1 // hm[1,2,1] // hm[1,3,1]) // μForm

(t2 = μ1 // hm[2,3,2] // hm[1,2,1]) // μForm

(t1-t2 ) // μForm

Compatibility of m and Δ

μ=α1 ar[1,1]+ α2 ar[2,2];
{
μ // hΔ[1,1,3] // hΔ[2,2,4] // hm[1,2,1] // hm[3,4,2],
μ // hm[1,2,1] // hΔ[1,1,2]
} // μForm

The Antipode Property

{
α ar[1,1] // hΔ[1,1,2] // hS[2] // hm[1,2,1],
α ar[1,1] // hΔ[1,1,2] // hS[2] // hm[2,1,1]
}

Factorization

hfac[z_, xtails_List -> x_, y_][μ_] := Module[
{ytails},
ytails = Complement[
Union[Cases[μ, t[s_] :> s, Infinity]],
xtails
];
hfac[z,xtails -> x, ytails -> y][μ]
];
hfac[z_, x_,  ytails_List -> y_][μ_] := Module[
{xtails},
xtails = Complement[
Union[Cases[μ, t[s_] :> s, Infinity]],
ytails
];
hfac[z,xtails -> x, ytails -> y][μ]
];
hfac[z_, xtails_List -> x_, ytails_List -> y_][μ_] := Module[
{ζ, ξ, η},
ζ = D[μ, h[z]];
ξ = ζ /. ((t[#]->0)& /@ ytails);
η = ζ /. ((t[#]->0)& /@ xtails);
μCollect[μ-h[z]ζ + h[x]ξ + h[y]η/(1+ξ /. t[s_]->c[s])]
]

hm[3,4,5][ar[1,3]+ar[2,4]] // μForm

hm[3,4,5][ar[1,3]+ar[2,4]] // hfac[5,{1}->3, 4]

Conjugation

conj[y_,x_][μ_] := Module[
{ν, x0, x1, γ, ξ, η, a},
ν = μ // hfac[x, {y} -> x0, x1];
γ = Coefficient[ν, ar[y,x0]];
ν = μCollect[ν /. W[ws_] :> W[ws*(c[y]γ+1)]];
ξ = D[ν, h[x1]];
η = D[ν, t[y]];
a = 1 + ξ /. t[s_] :> c[s];
ν = μCollect[(ν /. t[y] -> a t[y]) -c[y] ξ η];
ν // hm[x0,x1,x]
];
conji[y_,x_][μ_] := μ // hS[x] // conj[y,x] // hS[x];

{
μ1 = W[1]+ α ar[1,1] + β ar[1,2] + γ ar[2,1] +δ ar[2,2],
μ1 // conj[1,2],
μ1 // conji[1,2],
μ1 // conj[1,2] // conji[1,2]
} // μForm

(μ2 = W[1]+(Subscript[α, 1]) ar[1,1] + (Subscript[α, 2]) ar[2,1] + (Subscript[α, 3]) ar[2,2] + (Subscript[α, 4]) ar[2,3]) // μForm;
(μ2 = W[1]+Sum[(Subscript[α, i,j]) ar[i,j], {i,2}, {j,3}]) // μForm

μ2 // conj[1,2] // μForm

(t1 = μ2 // conj[1,2] // conj[1,3] // hm[2,3,2]) // μForm

(t2 = μ2 //  hm[2,3,2] // conj[1,2]) // μForm

Simplify[t1==t2]

Simplify[(μ2 // conji[1,2] // conji[1,3] // hm[3,2,2])== (μ2 //  hm[3,2,2] // conji[1,2])]

“4T”

Riffle[
ComposeList[
ops={conj[2,1], hΔ[1,1,3], hm[2,3,2], hΔ[1,1,3], hS[3], hm[3,2,2]},
(Subscript[α, 1]) ar[1,1] + (Subscript[α, 2]) ar[2,2]
]// μForm,
ops
]

(Subscript[α, 1]) ar[1,1] + (Subscript[α, 2]) ar[2,2](Exp[c[2]]-1)/c[2] // conj[2,1] // hΔ[1,1,3] // hm[2,3,2]//hΔ[1,1,3] // hS[3] // hm[3,2,2]// μForm

Riffle[
ComposeList[
ops={hΔ[1,1,3], hm[2,3,2], hΔ[1,1,3], hS[3], hm[3,2,2]},
(Subscript[α, 1]) ar[1,1] + (Subscript[α, 2]) ar[1,2]
]// μForm,
ops
]

The Double

dm[x_,y_,z_][μ_] := μ // conji[y,x] // hm[x,y,z] // tm[x,y,z];
dΔ[z_, x_, y_][μ_] := μ // hΔ[z,x,y] // tΔ[z,x,y];
dS[x_][μ_] := μ // tS[x] // conj[x,x] // hS[x];

Unprotect[NonCommutativeMultiply];
μ_ ** ν_ := Module[
{ρ, σ, labels},
ρ = μ + (ν /. {h[s_] :> h[σ[s]], t[s_] :> t[σ[s]], c[s_] :> c[σ[s]]});
ρ = ρ /. {
2W[a_] :> W[Simplify[a^2]],
W[a_]+W[b_] :> W[Simplify[a*b]]
};
labels = Union[Cases[{μ,ν}, h[s_]|t[s_]|c[s_] :> s, Infinity]];
Do[
ρ = ρ // dm[s, σ[s], s],
{s, labels}
];
ρ
]

ar[1,2]**ar[1,3]// μForm

ar[1,3]**ar[2,3] // μForm

ar[1,2]**ar[2,3] // μForm

{ar[1,2]**ar[1,3]**ar[2,3], ar[2,3]**ar[1,3]**ar[1,2]} // μForm

{R[1,2]**R[1,3]**R[2,3], R[2,3]**R[1,3]**R[1,2]} // μForm

ar[1,3]**ar[1,2] // μForm

ar[2,3]**ar[1,3] // μForm

ar[2,3]**ar[1,2] // μForm

{ar[1,2] // dS[1] , ar[1,2] // dS[2]}

{R[1,2], R[1,2] // dS[1] , R[1,2] // dS[2]}

(R[1,2]//dS[2])**R[1,2]

(R[1,2]//dS[1])**R[1,2]

{R[2,3]**dΔ[2,2,3][R[1,2]], dΔ[2,2,3][R[1,2]]**R[2,3]} // μForm

{ar[2,3]**dΔ[2,2,3][ar[1,2]], dΔ[2,2,3][ar[1,2]]**ar[2,3]} // μForm

{R[1,2]**dΔ[1,1,2][R[1,3]], dΔ[1,1,2][R[1,3]]**R[1,2]} // μForm

(V=W[ω]+ α ar[1,1] + β ar[1,2] + γ ar[2,1] + δ ar[2,2]) // μForm

{dΔ[1,1,2][ar[1,3]]**V, V**ar[1,3]**ar[2,3]} // μForm

SolveAlways[
dΔ[1,1,2][ar[1,3]]**V == V**ar[1,3]**ar[2,3], {h[1], h[2], h[3], t[1], t[2], c[1], c[2]}
]

{dΔ[1,1,2][R[1,3]]**V, V**R[1,3]**R[2,3]} // μForm

{dΔ[1,1,2][R[1,3]]**V, V**R[1,3]**R[2,3]} /. {E^c[1] -> X, E^c[2] -> Y, E^(c[1]+c[2]) -> X*Y}// μForm

sols = SolveAlways[
dΔ[1,1,2][R[1,3]]**V == V**R[1,3]**R[2,3]/. {E^c[1] -> X, E^c[2] -> Y, E^(c[1]+c[2]) -> X*Y}, {h[1], h[2], h[3], t[1], t[2], c[1], c[2], X, Y}
]